Attribute VB_Name = "mGradientFill"
Option Explicit

Private Type TRIVERTEX
   x As Long
   y As Long
   Red As Integer
   Green As Integer
   Blue As Integer
   Alpha As Integer
End Type
Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type
Private Declare Function GradientFill Lib "msimg32" ( _
   ByVal hdc As Long, _
   pVertex As TRIVERTEX, _
   ByVal dwNumVertex As Long, _
   pMesh As GRADIENT_RECT, _
   ByVal dwNumMesh As Long, _
   ByVal dwMode As Long) As Long

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Public Const CLR_INVALID = -1
Public Const CLR_NONE = CLR_INVALID

Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public Enum GradientFillStyle
 GRADIENT_FILL_RECT_H = 0
 GRADIENT_FILL_RECT_V = 1
 GRADIENT_FILL_TRIANGLE = &H2&
End Enum

Public Sub GradientFillRect( _
      ByVal lHDC As Long, _
      tR As RECT, _
      ByVal oStartColor As Long, _
      ByVal oEndColor As Long, _
      ByVal eDir As GradientFillStyle _
   )
Dim hBrush As Long
Dim lStartColor As Long
Dim lEndColor As Long
Dim lR As Long
   
   ' Use GradientFill:
   'If (HasGradientAndTransparency) Then
      lStartColor = TranslateColor(oStartColor)
      lEndColor = TranslateColor(oEndColor)
   
      Dim tTV(0 To 1) As TRIVERTEX
      Dim tGR As GRADIENT_RECT
      
      setTriVertexColor tTV(0), lStartColor
      tTV(0).x = tR.Left
      tTV(0).y = tR.Top
      setTriVertexColor tTV(1), lEndColor
      tTV(1).x = tR.Right
      tTV(1).y = tR.Bottom
      
      tGR.UpperLeft = 0
      tGR.LowerRight = 1
      
      GradientFill lHDC, tTV(0), 2, tGR, 1, eDir
      
   'Else
   '   ' Fill with solid brush:
   '   hBrush = CreateSolidBrush(TranslateColor(oEndColor))
   '   FillRect lHDC, tR, hBrush
   '   DeleteObject hBrush
   'End If
   
End Sub

Private Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long)
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
   lRed = (lColor And &HFF&) * &H100&
   lGreen = (lColor And &HFF00&)
   lBlue = (lColor And &HFF0000) \ &H100&
   setTriVertexColorComponent tTV.Red, lRed
   setTriVertexColorComponent tTV.Green, lGreen
   setTriVertexColorComponent tTV.Blue, lBlue
End Sub

Public Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function

Private Sub setTriVertexColorComponent(ByRef iColor As Integer, ByVal lComponent As Long)
   If (lComponent And &H8000&) = &H8000& Then
      iColor = (lComponent And &H7F00&)
      iColor = iColor Or &H8000
   Else
      iColor = lComponent
   End If
End Sub

